COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 DEFVST    					    -*-Mode:LispPackage:SI-*-
C00004 00003
C00008 00004
C00015 00005
C00017 00006
C00022 00007
C00025 ENDMK
C⊗;
;;; DEFVST    					    -*-Mode:Lisp;Package:SI-*-
;;; **************************************************************************
;;; ***** NIL ****** NIL/MACLISP/LISPM Structure Definer *********************
;;; **************************************************************************
;;; ******** (c) Copyright 1980 Massachusetts Institute of Technology ********
;;; ************ this is a read-only file! (all writes reserved) *************
;;; **************************************************************************

;;; Acronym for "DEFine a Vector-like STructure"
;;; For documentation and examples, see the file LIBDOC;DEFVST DOC on the
;;;   various ITS systems, and LISP:DEFVST.DOC  on TOPS10/20 systems.

;;; For MacLISP, to compile NADEFVST, just do (SSTATUS FEATURE NADEFVST)
;;;   at the COMPLR first.

(eval-when (eval compile)
	   (cond ((status nofeature MACLISP))
		 ((status feature NADEFVST) 
		  (sstatus feature For-NIL))
		 ((status nofeature For-NIL)
		  (sstatus feature FM)
		  (sstatus feature FOR-MACLISP)))
)

(herald DEFVST /132)

#-FM 
(globalize "DEFVST" 
	   "CONSTRUCTOR-NAMESTRING-PREFIX" 
	   "SELECTOR-NAMESTRING-STYLE" 
	   "STRUCT-LET" 
	   "STRUCT-SETF" 
   )



(eval-when (eval compile)
  (macro lispdir (x)
	(setq x (cadr x))
	#+(or NADEFVST (and FM Pdp10)) 
      `(QUOTE ((LISP) ,x))
	#+Lispm 
      (string-append "lisp;" (get-pname x) "qfasl")
	#+Multics 
      (catenate ">exl>lisp←dir>object" (get←pname x))
	#-(or NADEFVST FM LISPM) 
      (string-append "lisp:" (get-pname x) "vasl")
	)
  (macro subload (x)
	(setq x (cadr x))
	`(OR (GET ',x 'VERSION) (LOAD #%(LISPDIR ,x))))

  )


;; Load DEFVSX and DEFMAX now to get their "globalizations"
;; Load EXTEND before DEFVSX so that CLASS system will be available
#-For-NIL 
(eval-when (eval compile load)
    (subload EXTEND)	;Bring these guys in before DEFVSX,
    (subload EXTMAC)	; so that the CLASS system will be
    (subload VECTOR)	; alive by then.
    (subload DEFVSX)
)

#+NADEFVST
  (eval-when (eval compile)
    (subload EXTEND)	;Bring these guys in before DEFVSX,
    (subload EXTMAC)	; so that the CLASS system will be
    (subload VECTOR)	; alive by then.
    (subload DEFVSX)
    (subload DEFSETF)
    (subload UMLMAC))
  )



(declare (special DEFMACRO-DISPLACE-CALL 
		  CONSTRUCTOR-NAMESTRING-PREFIX 
		  SELECTOR-NAMESTRING-STYLE 
		  STRUCT-CLASS 
		  STRUCT=INFO-CLASS 
		  |defvst-typchk/||
		  |defvst-construction/||)
    #M   (*expr |defvst-construction/|| |defvst-construction-1/|| 
		|defvst-typchk/|| )
    #M   (*lexpr TO-VECTOR))


(MAPC '(LAMBDA (X Y) (AND (NOT (BOUNDP X)) (SET X Y)))
      '(SELECTOR-NAMESTRING-STYLE  CONSTRUCTOR-NAMESTRING-PREFIX )
      '(|-|  |CONS-A-| ))

#M(declare (own-symbol DEFVST STRUCT-LET STRUCT-SETF))

#+NADEFVST (includef '((NILCOM) DEFVSY))
#+NADEFVST (includef '((NILCOM) DEFVSX))

;; FOO! to prevent circularities when compiling
#M 
(eval-when (compile) 
    (do ((i 0 (1+ i))
	 (l '(VERS NAME CNSN SIZE INIS CLSS) (cdr l))
	 (z))
	((null l))
      (setq z (symbolconc 'STRUCT=INFO- (car l)))
      (eval `(DEFMACRO ,z (X) `(SI:XREF ,X ,,i))))
)


;;;; DEFVST macro

(defmacro (DEFVST defmacro-displace-call () ) (sname &rest selkeys)
   (LET ((NKEYS 0)
	 (SELECTOR-NAMESTRING-STYLE SELECTOR-NAMESTRING-STYLE)
	 (CONSTRUCTOR-NAMESTRING-PREFIX CONSTRUCTOR-NAMESTRING-PREFIX)
	 CONSTRUCTOR-NAME  RESTKEY  RESTSIZEFORM  RESTP  SELINIS  MAC-ARG-NM  
	 TMP)
	(DECLARE (FIXNUM I NKEYS))
	(AND (NOT (ATOM SNAME))
	     (SETQ SNAME (PROG2 () (CAR SNAME)
				   (DO L (CDR SNAME) (CDDR L) (NULL L)
				       (OR (EQ (CAR L) 'DEFMACRO-DISPLACE-CALL)
					   (SET (CAR L) (EVAL (CADR L))))) )))
	(AND (OR (NULL SNAME) (NOT (SYMBOLP SNAME)))
	     (ERROR "Bad args - DEFVST" (CONS SNAME SELKEYS)))
	(SETQ NKEYS (LENGTH SELKEYS))
	(COND ((SETQ TMP (MEMQ '&REST SELKEYS))
	       (SETQ NKEYS (- NKEYS (LENGTH TMP))
		     RESTKEY (CADR TMP)
		     RESTSIZEFORM (CADDR TMP))
	       (AND (OR (NOT (SYMBOLP RESTKEY)) (NULL RESTSIZEFORM))
		    (ERROR "Lossage in &REST variable - DEFVST" SELKEYS))))
	(COND ((GET SNAME 'STRUCT=INFO)
	       (TERPRI MSGFILES)
	       (PRINC "Warning!  Redefining the STRUCTURE " MSGFILES)
	       (PRIN1 SNAME MSGFILES)))
	(SETQ MAC-ARG-NM (INTERN (SYMBOLCONC SNAME '|-MACRO-ARG|))
	      CONSTRUCTOR-NAME SNAME)
	(AND CONSTRUCTOR-NAMESTRING-PREFIX 
	     (SETQ CONSTRUCTOR-NAME 
		   (INTERN (SYMBOLCONC CONSTRUCTOR-NAMESTRING-PREFIX SNAME))))
         ;RESTP and SELINIS start out null here
	(DO ( (I 1 (1+ I)) 
	      (L SELKEYS (CDR L)) 
	      INIFORM TYP  /=-/:-COUNT  KEYNM  SELNM )
	    ( (OR (NULL L) RESTP) )
	  (COND ((ATOM (SETQ KEYNM (CAR L))) 
		 (COND ((EQ KEYNM '&REST)
			(SETQ KEYNM RESTKEY  RESTP 'T)
			(AND (NOT (EQ RESTKEY (CADR L))) 
			     (ERROR '|&REST lossage DEFVST|)))
		       ((NOT (SYMBOLP KEYNM)) 
			(ERROR '|KEY NAME NOT A SYMBOL - DEFVST| KEYNM)))
		 (SETQ INIFORM () ))
		('T (AND (OR (NULL (SETQ KEYNM (CAR KEYNM)))
			     (NOT (SYMBOLP KEYNM)))
			(ERROR '|Bad key-list - DEFVST| SELKEYS))
		    (COND ((ATOM (SETQ TMP (CDAR L))) (SETQ INIFORM () ))
			  ('T (SETQ /=-/:-COUNT 0 )
			      (AND (NULL (CDR TMP))		;Allow LISPM-
				   (SETQ TMP `(= ,(car tmp))))	; style inits
			      (COND ((SETQ TYP (MEMQ '|:| TMP))
				     (SETQ /=-/:-COUNT 1)
				     (SETQ TYP (COND ((ATOM (CADR TYP))
						      (LIST (CADR TYP)))
						     ((CADR TYP))))))
			      (SETQ INIFORM
				    (COND ((SETQ INIFORM (MEMQ '= TMP))
					   (SETQ /=-/:-COUNT (1+ /=-/:-COUNT))
					   (CADR INIFORM))
					  (TYP (CDR (OR (ASSQ 
							  (CAR TYP)
							  '((FIXNUM . 0) 
							    (FLONUM . 0.0)
							    (BIGNUM . 500000000000000000000.)
							    (LIST . () )
							    (SYMBOL . FOO)
							    (ARRAY . () )
							    (HUNK . () )
							    ))
					      #+For-NIL (ASSQ (CAR TYP)
							      '((SMALL-FLONUM 0.0)
								(PAIR . '(() ))
							;fix...	(VECTOR . #() )
								(STRING . "" )))
						)))))
			      (AND (NOT (= /=-/:-COUNT 0)) 
				   (SETQ INIFORM (CONS INIFORM TYP)))
			      (COND ((NOT (= (* 2 /=-/:-COUNT) (LENGTH TMP)))
				     (PRINT (CAR L) MSGFILES)
				     (PRINC "Options list has options not yet coded "))) 
			      )) 
		    ))
	  (SETQ SELNM KEYNM)
	  (AND SELECTOR-NAMESTRING-STYLE
	       (SETQ SELNM (INTERN (SYMBOLCONC SNAME 
					       SELECTOR-NAMESTRING-STYLE 
					       KEYNM))))
	  (COND ((NOT RESTP) 
		   ;; INIFORM = (<initialization-form> <restrictions>...)
		 (PUSH `(,keynm ,selnm ,.iniform) SELINIS))
		('T  (SETQ RESTP `(,keynm ,selnm ,restsizeform))
		     (OR (= I (1+ NKEYS)) (ERROR '|Missed &REST key?| I)))))
	`(EVAL-WHEN (EVAL COMPILE LOAD)
	   #+FM (defprop |defvst-initialize/|| #.(lispdir DEFVSY) AUTOLOAD)
		(AND (STATUS FEATURE COMPLR) 
		     (SPECIAL ,(symbolconc sname '/-CLASS)))
		(|defvst-initialize/|| 
		    ',sname 
		    ',constructor-name 
		    ,nkeys 
		    ',(to-vector (cons restp (nreverse selinis)))
		    1
;; Leave commented out until old dumps die out -- RWK 29 December 1980
;;		    ,(and (filep infile) `',(truename infile))
		    )
;; The next should be flushed when the above is un-commented-out
;;   RWK -- 29 December 1980
		,@(and (filep infile)
		       `((setf (get (si:class-plist (get ',sname 'CLASS))
				    ':SOURCE-FILE)
			       ',(truename infile))))
		,.(if restp 
		      `((DEFPROP ,(cadr restp) 
				 (,sname ,(1+ nkeys) &REST) 
				 SELECTOR)))
		',sname)))


;;;; STRUCT-LET and STRUCT-SETF 

;;; E.g. (STRUCT-LET ((structure-name struct-object-to-be-destructured)
;;		      (var slot-name)			; or,
;;		      (var-named-same-as-slot)		; or,
;;		      var-named-same-as-slot 
;;		      ...)
;;		    . body)

(defmacro (STRUCT-LET defmacro-displace-call '|defvst-construction/||) 
	  ((struct-name str-obj) bvl &rest body)
   (let (var slot-name accessor)
	(setq bvl (mapcar 
		   '(lambda (e)
			(if (atom e) (setq e `(,e ,e)))
			(desetq (var slot-name) e)
			(or slot-name (setq slot-name var))
			(setq accessor (symbolconc struct-name '/- slot-name))
			`(,var (,accessor ,str-obj)))
		   bvl))
	`(LET ,bvl ,.body)))


;;; E.g. (STRUCT-SETF (structure-name object) (slot-name value) ...)
(defmacro (STRUCT-SETF defmacro-displace-call '|defvst-construction/||) 
	  ((str-name str-obj) &rest l &aux slot-name accessor val)
   `(PROGN ,. (mapcar 
	       '(lambda (x)
		   (desetq (slot-name val) x)
		   (setq accessor (symbolconc str-name '/- slot-name))
		   `(SETVST (,accessor ,str-obj) ,val))
	       l)))



;;;; Structure Printer
;; Someday, hack printing of &REST stuff

(DEFVAR SI:PRINLEVEL-EXCESS '|#|)
(DEFVAR SI:PRINLENGTH-EXCESS '|...|)

(DEFMETHOD* (PRINT STRUCT-CLASS) (OB STREAM DEPTH SLASHIFYP)
  (DECLARE (FIXNUM DEPTH))
  (SETQ DEPTH (1+ DEPTH))
  (COND ((AND PRINLEVEL (NOT (< DEPTH PRINLEVEL)))
	 (PRINC SI:PRINLEVEL-EXCESS STREAM))
	(T (SI:CHECK-DEFVST-VERSION  (SI:CLASS-NAME (CLASS-OF OB)))
	   (LET* ((TYP (SI:CLASS-NAME (CLASS-OF OB)))
		  (INFO (GET TYP 'STRUCT=INFO)))
		 (COND ((NULL INFO) (SI:PRINT-EXTEND-MAKNUM OB STREAM))
		       (T (PRINC '|#{| STREAM)
			  (DO ((Z (SI:LISTIFY-STRUCT-FOR-PRINT OB TYP INFO)
				  (CDR Z))
			       (N 0 (1+ N))
			       (FIRST 'T ()))
			      ((NULL Z))
			      (DECLARE (FIXNUM N))
			      (OR FIRST (TYO #\SPACE STREAM))
			      (PRINT-OBJECT (CAR Z) DEPTH SLASHIFYP STREAM)
			      (COND ((AND PRINLENGTH (NOT (< N PRINLENGTH)))
				     (TYO #\SPACE STREAM)
				     (PRINC SI:PRINLENGTH-EXCESS STREAM)
				     (RETURN ()))))
			  (TYO #/} stream)))))))

(DEFMETHOD* (SPRINT STRUCT-CLASS) (OB N M)
  (DECLARE (SPECIAL L N M))
  (SI:CHECK-DEFVST-VERSION (SI:CLASS-NAME (CLASS-OF OB)))
  (LET* ((TYP (SI:CLASS-NAME (CLASS-OF OB)))
	 (INFO (GET TYP 'STRUCT=INFO)))
	(COND ((NULL INFO) (SI:PRINT-EXTEND-MAKNUM OB OUTFILES))
	      (T (LET ((Z (SI:LISTIFY-STRUCT-FOR-PRINT OB TYP INFO)))
		      (COND ((> (- (GRCHRCT) 3.) (GFLATSIZE Z))
			     (PRIN1 OB))
			    (T (PRINC '|#{|)
			       (PRIN1 (CAR Z))
			       (COND ((CDR Z)
				      (TYO #\SPACE)
				      (SETQ N (GRCHRCT) M (1+ M))
				      (DO ((L (CDR Z)))
					  ((NULL L))
					  (GRINDFORM 'LINE)
					  (GRINDFORM 'CODE)
					  (COND (L (INDENT-TO N))))))
			       (TYO #/}))))))))
		      

;; Sure, this could do less consing, if it really wanted to.  But who
;; wants to trouble to write such hairy code?
(DEFUN SI:LISTIFY-STRUCT-FOR-PRINT (OB TYP INFO)
  (LET* ((SUPPRESS (GET TYP 'SUPPRESSED-COMPONENT-NAMES))
	 (INIS (STRUCT=INFO-INIS INFO)))
	(DO ((I 1 (1+ I))
	     (N (*:EXTEND-LENGTH INIS))		;actually, VECTOR-LENGTH
	     (THE-LIST (LIST TYP)))
	    ((NOT (< I N)) (NREVERSE THE-LIST))
	     ;The (1+ i)th component of INIS corresponds to the ith
	     ;component of OB.  The 0th component of INIS corresponds
	     ;to the &REST stuff which this code doesn't address.
	    (LET* (((NAME SELECTOR INIT) (*:XREF INIS I))	;actually, VREF
		   (VAL (*:XREF OB (CADR (GET SELECTOR 'SELECTOR)))))
		  (COND ((MEMQ NAME SUPPRESS))
			;;Incredible kludge to avoid printing defaulted vals
			((OR (AND (NULL INIT) (NULL VAL))
			     (AND (|constant-p/|| INIT)
				  (EQUAL VAL (EVAL INIT)))
			     (AND (PAIRP INIT)
				  (EQ (CAR INIT) 'QUOTE)
				  (EQUAL VAL (CADR INIT)))))
			(T (PUSH NAME THE-LIST)
			   (PUSH VAL THE-LIST)))))))




(defmethod* (EQUAL struct-class) (ob other)
  (or (eq ob other)		;generally, this will have already been done
      (let ((ty1 (struct-typep ob))
	    (ty2 (struct-typep other)))
	(cond ((or (null ty1) (null ty2) (not (eq ty1 ty2))) () )
	      ((si:component-equal ob other))))))


(defmethod* (SUBST struct-class) (ob a b)
   (si:subst-into-extend ob a b))

(defmethod* (SXHASH struct-class) (ob)
   (si:hash-Q-extend ob #.(sxhash 'STRUCT)))

(defmethod* (DESCRIBE struct-class) (ob stream level)
   (cond ((not (> level si:describe-max-level))
	  (si:check-DEFVST-version (struct-typep ob))
	  (let* ((typ (struct-typep ob))
		 (inis (struct=info-inis (get typ 'struct=info)))
		 (ninis (*:extend-length inis))
		 (suppress (get typ 'suppressed-component-names)))
		(format stream '|}%}vTThe named structure has STRUCT-TYPEP }S|
			level typ)
		(cond (suppress
		       (format stream '|}%}vtThese component names are suppressed: }S|
			       level suppress)))
		(format stream '|}%}vtThe }D. component names and contents are:|
			level (1- ninis))
		(do ((i 1 (1+ i)) (default () ()))
		    ((not (< i ninis)))
		    (let* (((name selector init) (*:xref inis i))
			   (val (*:xref ob (cadr (get (cadr (*:xref inis i))
						      'selector)))))
			  (cond ((or (and (null init) (null val))
				     (and (|constant-p/|| init)
					  (equal val (eval init)))
				     (and (pairp init)
					  (eq (car init) 'quote)
					  (equal val (cadr init))))
				 (setq default 'T)))
			  (format stream '|}%}vt  }S: }S }:[}; [default]}]|
				  level (car (*:xref inis i)) val default)))
		(cond ((*:xref inis 0)
		       (format stream '|}%}vt&REST part hasn't been Described.|
			       level)))))))